home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue28 / subclass / awkworks.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-09-06  |  3.6 KB  |  135 lines
  1. unit awkworks;
  2. interface
  3. uses
  4.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  5.   ExtCtrls;
  6.  
  7. type
  8.   eAwkwardError = class(exception);
  9.  
  10.   TAwkwardComp = class(TCustomPanel)
  11.   private
  12.    fNewWindowProc : TFarProc;  {pointer to our window function}
  13.    fOldWindowProc : longint;   {previous window function }
  14.    fTargetHandle : hWnd;
  15.   protected
  16.     { Protected declarations }
  17.   public
  18.     constructor create(aOwner: tcomponent); override;
  19.     destructor destroy; override;
  20.     function turnOnSubClassing: boolean;
  21.     procedure TurnOffSubClassing;
  22.   published
  23.     property Align;
  24.     property Alignment;
  25.     property BevelInner;
  26.     property BevelOuter;
  27.     property BevelWidth;
  28.     property BorderWidth;
  29.     property BorderStyle;
  30.     property DragCursor;
  31.     property DragMode;
  32.     property Enabled;
  33.     property FullRepaint;
  34.     property Caption;
  35.     property Color;
  36.     property Ctl3D;
  37.     property Font;
  38.     property Locked;
  39.     property ParentColor;
  40.     property ParentCtl3D;
  41.     property ParentFont;
  42.     property ParentShowHint;
  43.     property PopupMenu;
  44.     property ShowHint;
  45.     property TabOrder;
  46.     property TabStop;
  47.     property Visible;
  48.     property OnClick;
  49.     property OnDblClick;
  50.     property OnDragDrop;
  51.     property OnDragOver;
  52.     property OnEndDrag;
  53.     property OnEnter;
  54.     property OnExit;
  55.     property OnMouseDown;
  56.     property OnMouseMove;
  57.     property OnMouseUp;
  58.     property OnResize;
  59.     property OnStartDrag;
  60.   end;
  61.  
  62. function NewFormFunction(handle: hWnd; msg, wParam : Word; lParam : LongInt): LongInt; stdcall;
  63.  
  64. procedure Register;
  65.  
  66. implementation
  67.  
  68. const cMyID : pchar = 'xyz';
  69.  
  70. function NewFormFunction(handle: hWnd; msg, wParam : Word; lParam : LongInt): LongInt;
  71. var ThisInstance : longint;
  72. begin
  73.   ThisInstance := getProp(handle, cMyID);
  74.   if TAwkwardComp(ThisInstance).enabled
  75.     then case msg of
  76.      WM_LBUTTONDOWN : TAwkwardComp(ThisInstance).color := clLime;
  77.      WM_RBUTTONDOWN : TAwkwardComp(ThisInstance).color := clWhite;
  78.      end;
  79.  Result := CallWindowProc(TFarProc(TAwkwardComp(ThisInstance).fOldWindowProc),
  80.                            Handle, Msg, wParam, lParam);
  81. end;
  82.  
  83.  
  84. constructor TAwkwardComp.create(aOwner: tcomponent);
  85. begin
  86.   inherited create(aowner);
  87.   fTargetHandle := tform(aOwner).handle;
  88.   // note that this will only work if we do infact want to subclass the owning form, rather than the parent
  89.   // which is fine for non-visual components
  90.   bevelInner := bvLowered;
  91.   bevelWidth := 3;
  92.   caption := 'Subclassing off';
  93.   if not TurnOnSubClassing
  94.     then raise eawkwardError.create('Could not subclass awkard');
  95. end;
  96.  
  97. destructor TAwkwardComp.destroy;
  98. begin
  99.   turnoffSubClassing;
  100.   inherited destroy;
  101. end;
  102.  
  103. function TAwkwardComp.turnOnSubClassing : boolean;
  104. var lresult : longint;
  105. begin
  106.    if SetProp(fTargetHandle, cMyID, longint(self))
  107.      then result := true
  108.      else begin
  109.        result := false;
  110.        exit;
  111.        end;
  112.    fOldWindowProc := GetWindowLong(fTargetHandle, GWL_WNDPROC);
  113.    fNewWindowProc := @NewFormFunction;
  114.    SetLastError(0);  {help file suggests this}
  115.    lResult := SetWindowLong(fTargetHandle, GWL_WNDPROC, LongInt(fNewWindowProc));
  116.    if lResult = 0
  117.      then result := false
  118.      else result := true;
  119.    caption := 'Subclassing on';
  120. end;
  121.  
  122. procedure TAwkwardComp.TurnOffSubClassing;
  123. begin
  124.    SetWindowLong(fTargetHandle, GWL_WNDPROC, longint(fOldWindowProc));
  125.    caption := 'Subclassing off';
  126.    color := clBtnFace;
  127. end;
  128.  
  129. procedure Register;
  130. begin
  131.   RegisterComponents('Samples', [TAwkwardComp]);
  132. end;
  133.  
  134. end.
  135.